home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / PowerMacOberon feb96 / Source / Kernel.Mod (.txt) < prev    next >
Encoding:
Oberon Text  |  1996-01-25  |  24.6 KB  |  688 lines  |  [TEXT/.Ob4]
  1. Syntax10.Scn.Fnt
  2. InfoElems
  3. Alloc
  4. Syntax10.Scn.Fnt
  5. StampElems
  6. Alloc
  7. 25 Jan 96
  8. "Title": Kernel.Mod
  9. "Author": mmb 8.5.91 / 13.10.93 / RC 28.10.91 / HM 27.6.94 / mah 16.12.94
  10. "From":  10.02.95 12:30:34
  11. "Until": 
  12. "Changes":
  13. 10.2.95    mah    ptrs <= 0 not marked anymore instead of ptr = 0 as previously
  14. 17.2.95    mah    best fit instead of first fit when allocating a big block 
  15. 27.6.95    mk     finalization, queues are now stacks, prepare Queue added
  16. 29.11.95  mah    CheckCandidates: fix to avoid marking of free blocks
  17. 30.11.95  mah    CHeckCandidates: ptr into block -> block not freed (e.g. VAR-Par p.x on stack. p = NIL)
  18. Syntax10b.Scn.Fnt
  19. Syntax10i.Scn.Fnt
  20. FoldElems
  21. Syntax10.Scn.Fnt
  22. IF (heapSize > minHeapSize) & (lastSize >= minHeapExt) THEN    (*<<*)
  23.             lastSize := ShrinkHeap(lastSize)
  24.         END;
  25. Syntax10.Scn.Fnt
  26.         VAR p: FreeBlock; i, size: LONGINT;
  27.     BEGIN
  28.         p := S.VAL(FreeBlock, lastBlock);
  29.         IF p # NIL THEN DEC(requiredSize, p.size + 4) END;
  30.         size := S.VAL(LONGINT, S.VAL(SET, requiredSize+(minHeapExt-1)) - S.VAL(SET, minHeapExt-1));
  31.         Sys.SetPtrSize(heapAdr, heapSize + size);
  32.         IF Sys.MemError() # 0 THEN Sys.Str("Heap overflow$"); HALT(20) END;
  33.         requiredSize := size;
  34.         IF p # NIL THEN
  35.             i := p.size + 4; INC(size, i);
  36.             i := Min(i DIV B, N);
  37.             A[i] := p.next
  38.         ELSE p := S.VAL(FreeBlock, heapEnd)
  39.         END;
  40.         p.tag := S.VAL(Tag, S.ADR(p.size)); p.size := size - 4;
  41.         p.next := A[N]; A[N] := p;
  42.         INC(heapSize, requiredSize); INC(heapEnd, requiredSize)
  43.     END ExpandHeap;
  44. Syntax10.Scn.Fnt
  45.         VAR shrink, newSize: LONGINT;
  46.     BEGIN
  47.         shrink := S.VAL(LONGINT, S.VAL(SET, lastSize) - S.VAL(SET, minHeapExt-1));
  48.         newSize := heapSize - shrink;
  49.         IF newSize < minHeapSize THEN newSize := minHeapSize; shrink := heapSize - minHeapSize END;
  50.         Sys.SetPtrSize(heapAdr, newSize); 
  51.         IF Sys.MemError() # 0 THEN RETURN lastSize
  52.         ELSE DEC(heapSize, shrink); DEC(heapEnd, shrink); RETURN lastSize - shrink
  53.         END
  54.     END ShrinkHeap;
  55. Syntax10.Scn.Fnt
  56.         VAR tag, supertag, x, y: LONGINT; typename: ARRAY 32 OF CHAR; m: Modules.Module;
  57.     BEGIN
  58.         x := p-4;
  59.         REPEAT INC(x, 4); S.GET(x, y) UNTIL y < 0;
  60.         tag := x + y;
  61.         S.GET(tag-4, supertag);
  62.         supertag := S.VAL(LONGINT, S.VAL(SET, supertag) - mark);
  63.         S.MOVE(supertag+16, S.ADR(typename), 32);
  64.         IF (typename # "ObjDesc") & (typename # "StrDesc") & (typename # "NodeDesc") THEN
  65.             S.GET(supertag+48, m);
  66.             Modules.Print(m.name, 0); Modules.Print(". ", 0);
  67.             Modules.Print(typename, 0); Modules.Print(", n = %d$", (p-tag-4) DIV 4)
  68.         END
  69.     END PrintType;
  70. MODULE Kernel;    (* mmb 8.5.91 / 13.10.93 / RC 28.10.91 / HM 27.6.94 / mah 16.12.94 *)
  71. (* Finalization due to J.Templ  implemented by MK 22.2.95 *)
  72. (* memory management and trap handling for PowerMac Oberon *)
  73. (* WARNING: do not use NEW nor SYSTEM.NEW in this module !! use NewRec, NewArr or NewSys instead *)
  74.     IMPORT S := SYSTEM, Modules, Sys;
  75.     CONST
  76.         MarkBit* = 31; ArrayBit = 30; RecBit = 30;
  77.         B = 16;   (*chunk size: memory blocks are allocated in multiples of B bytes*)
  78.         N = 9;  (*number of free lists*)
  79.         mark = {MarkBit}; array = {ArrayBit};
  80.     TYPE
  81.         Tag = POINTER TO TypeDesc;
  82.         TypeDesc = RECORD
  83.             size: LONGINT;
  84.             ptroff: LONGINT
  85.         END;
  86.         FreeBlock = POINTER TO FreeBlockDesc;
  87.         FreeBlockDesc = RECORD
  88.             tag: Tag;
  89.             size: LONGINT;    (*size of block without tag*)
  90.             next: FreeBlock;
  91.             filler: LONGINT;
  92.             firstofnext: LONGINT
  93.         END;
  94.         Block* = POINTER TO BlockDesc;
  95.         BlockDesc = RECORD
  96.             last, cur, first: Block    (*fields of open array descriptor*)
  97.         END;
  98.         Blockm4 = POINTER TO Blockm4Desc;
  99.         Blockm4Desc = RECORD
  100.             tag: Tag;
  101.             last, cur, first: LONGINT;
  102.             filler0, filler1, filler2, filler3, firstofnext: LONGINT
  103.         END;
  104.         Stack = POINTER TO StackDesc;
  105.         StackDesc = RECORD
  106.             beg, end: LONGINT;
  107.             next: Stack
  108.         END;
  109.         Notifier* = PROCEDURE;
  110.         Queue* = RECORD
  111.             notify: ARRAY 8 OF Notifier
  112.         END;
  113.         Finalizer* = PROCEDURE (obj: S.PTR);
  114.         FinObj = POINTER TO FinObjNode;
  115.         FinObjNode = RECORD 
  116.             next: FinObj;
  117.             obj: LONGINT;
  118.             marked: BOOLEAN;
  119.             fin: Finalizer
  120.         END;    
  121.         heapBeg*, heapEnd*: LONGINT;    (*borders of used heap (B aligned - 4)*)
  122.         resumeSP*: LONGINT;    (*SP of Oberon.Loop*)
  123.         GCenabled*: BOOLEAN;
  124.         prepQ*, quitQ*, gcQ*, afterQ*: Queue; (* prep queue called before GC, gc queue during GC *)
  125.         finalize: BOOLEAN;  (* flag to avoid finalization in the case: Finalizer starts GC  MK *)
  126.         heapAdr, heapSize: LONGINT;    (*actual heap address and size*)
  127.         resumePC, resumeFP: LONGINT;    (*resume execution after trap here*)
  128.         A: ARRAY N+1 OF FreeBlock;  (*free lists*)
  129.         PointerTD, stackTD: ARRAY 4 OF LONGINT;
  130.         firstStack, curStack: Stack;
  131.         firstTry, checkStack: BOOLEAN;
  132.         nofcand: INTEGER;
  133.         finObjs*: FinObj;        (* list of objects to be finalized *)
  134.     PROCEDURE^ NewBlock (size: LONGINT): FreeBlock;
  135.     PROCEDURE^ NewRec (tg: LONGINT): LONGINT;
  136.     PROCEDURE^ NewSys (size: LONGINT): LONGINT;
  137.     PROCEDURE^ NewArr (eltg, nofelem, nofdim: LONGINT): LONGINT;
  138.     PROCEDURE^ Mark* (block: Block);
  139.     PROCEDURE Min (x, y: LONGINT): LONGINT;
  140.     BEGIN
  141.         IF x < y THEN RETURN x ELSE RETURN y END
  142.     END Min;
  143. (* --- queues --- *)
  144.     PROCEDURE (VAR q: Queue) Init*;
  145.         VAR i: INTEGER;
  146.     BEGIN
  147.         FOR i := 0 TO LEN(q.notify)-1 DO q.notify[i] := NIL END
  148.     END Init;
  149.     PROCEDURE (VAR q: Queue) Add* (notify: Notifier);
  150.         VAR i: INTEGER;
  151.     BEGIN
  152.         FOR i := 0 TO LEN(q.notify)-1 DO
  153.             IF q.notify[i] = NIL THEN q.notify[i] := notify; RETURN END
  154.         END
  155.     END Add;
  156.     PROCEDURE (VAR q: Queue) Remove* (notify: Notifier);
  157.         VAR i: INTEGER;
  158.     BEGIN
  159.         FOR i := 0 TO LEN(q.notify)-1 DO
  160.             IF q.notify[i] = notify THEN q.notify[i] := NIL; RETURN END
  161.         END
  162.     END Remove;
  163.     PROCEDURE (VAR q: Queue) Handle*;
  164.         VAR i: INTEGER;
  165.     BEGIN
  166.         FOR i := LEN(q.notify)-1 TO 0 BY - 1 DO
  167.             IF q.notify[i] # NIL THEN q.notify[i] END
  168.         END
  169.     END Handle;
  170. (* --- finalization --- *)
  171.     PROCEDURE RegisterObject* (obj: S.PTR; fin: Finalizer);
  172.         VAR n, n1: FinObj;
  173.         PROCEDURE new (VAR o: S.PTR);
  174.             VAR adr: LONGINT;
  175.         BEGIN 
  176.             adr := NewRec (S.VAL (LONGINT, o));
  177.             S.PUT (S.ADR (o), adr);
  178.         END new;
  179.     BEGIN
  180.         new (n); n.obj := S.VAL (LONGINT, obj); n.marked :=  TRUE; n.fin := fin; n.next := NIL; 
  181.         IF finObjs = NIL THEN finObjs :=n
  182.         ELSE
  183.             n1 := finObjs;
  184.             WHILE n1.next # NIL DO n1 := n1.next END;  
  185.             n1.next := n
  186.         END
  187.     END RegisterObject;
  188.     PROCEDURE FinalizeObjs;
  189.         VAR n, prev: FinObj;
  190.     BEGIN
  191.         IF finalize THEN RETURN END;
  192.         finalize := TRUE;
  193.         n := finObjs; prev := NIL;
  194.         WHILE n # NIL DO
  195.             IF ~ n.marked THEN
  196.                 n.fin (S.VAL (S.PTR, n.obj));
  197.                 IF n = finObjs THEN finObjs := finObjs.next ELSE prev.next := n.next END;
  198.             ELSE prev := n
  199.             END;
  200.             n := n.next
  201.         END;
  202.         finalize := FALSE;
  203.     END FinalizeObjs;
  204.     PROCEDURE FinalizeAll*;
  205.         VAR n, prev: FinObj;
  206.     BEGIN
  207.         finalize := TRUE;
  208.         n := finObjs; 
  209.         WHILE n # NIL DO n.fin (S.VAL (S.PTR, n.obj)); n := n.next END
  210.     END FinalizeAll;
  211.     PROCEDURE CheckFinObjs;
  212.         VAR n: FinObj; tag: LONGINT;
  213.     BEGIN
  214.         n := finObjs;
  215.         WHILE n # NIL DO
  216.             S.GET (n.obj - 4, tag);
  217.             n.marked := MarkBit IN S.VAL (SET, tag);
  218.             n := n.next
  219.         END;
  220.         (* marks all objects accessible from not marked n.obj s to prevent them from being collected *)
  221.         n := finObjs;
  222.         WHILE n # NIL DO    
  223.             S.GET (n.obj - 4, tag);
  224.             IF ~n.marked THEN Mark (S.VAL (Block, n.obj)) END;
  225.             n := n.next
  226.         END;
  227.     END CheckFinObjs;
  228. (* --- memory management --- *)
  229.     PROCEDURE AllocateHeap;
  230.         VAR grow: LONGINT;
  231.     BEGIN
  232.         Sys.MaxApplZone;
  233.         heapSize := Sys.MaxMem(grow) - 1000*1024;
  234.         heapAdr := Sys.NewPtr(heapSize);
  235.         IF heapAdr <= 0 THEN Modules.Print("-- could not allocate heap$", 0) END;
  236.     END AllocateHeap;
  237.     PROCEDURE Available* (): LONGINT;
  238.         VAR i, avail: LONGINT; p: FreeBlock;
  239.     BEGIN
  240.         avail := 0;
  241.         FOR i := 0 TO N DO
  242.             p := A[i];
  243.             WHILE p # NIL DO INC(avail, p.size+4); p := p.next END
  244.         END;
  245.         RETURN avail
  246.     END Available;
  247.     PROCEDURE LargestAvailable* (): LONGINT;
  248.         VAR i, max: LONGINT; p: FreeBlock;
  249.     BEGIN
  250.         i := N; max := 0;
  251.         WHILE (i >= 0) & (max = 0) DO
  252.             p := A[i];
  253.             WHILE p # NIL DO
  254.                 IF p.size > max THEN max := p.size END;
  255.                 p := p.next
  256.             END;
  257.             DEC(i)
  258.         END;
  259.         RETURN max + 4
  260.     END LargestAvailable;
  261.     PROCEDURE RemoveStack* (pos: LONGINT);
  262.         VAR s, last: Stack;
  263.     BEGIN
  264.         s := firstStack;
  265.         WHILE (s # NIL) & ((pos < s.beg) OR (pos > s.end)) DO last := s; s := s.next END;
  266.         IF (s # NIL) & (s # curStack) THEN
  267.             IF s = firstStack THEN firstStack := s.next ELSE last.next := s.next END
  268.         END
  269.     END RemoveStack;
  270.     PROCEDURE AddStack* (beg, end: LONGINT);
  271.         VAR s: Stack;
  272.     BEGIN
  273.         RemoveStack(beg);
  274.         s :=S.VAL(Stack, NewRec(S.ADR(stackTD)+4)) ; s.beg := beg; s.end := end; s.next := firstStack; firstStack := s
  275.     END AddStack;
  276.     PROCEDURE MarkStack*;
  277.         VAR SP: LONGINT;
  278.     BEGIN
  279.         S.GETREG(1, SP); S.GET(SP, curStack.end)
  280.     END MarkStack;
  281.     PROCEDURE Mark* (block: Block);
  282.         TYPE
  283.             Tag0 = POINTER TO RECORD
  284.                 (*size: LONGINT;  skipped, because accessed via tag = actual tag + 4*)
  285.                 ptroff: LONGINT
  286.             END;
  287.         VAR cur, prev, p: Block; offset, adr, tdadr: LONGINT; tag, downtag, marked: Tag0; arraybit, set: SET;
  288.     BEGIN
  289.         S.GET(S.VAL(LONGINT, block)-4, tag);
  290.         marked := S.VAL(Tag0, S.VAL(SET, tag) + mark);
  291.         IF tag # marked THEN
  292.             (*---- mark type descriptor*)
  293.             tdadr := S.VAL(LONGINT, S.VAL(SET, tag) - array) - 4;
  294.             S.GET (tdadr, set); 
  295.             IF RecBit IN set THEN tdadr := S.VAL(LONGINT, set - {RecBit, MarkBit}) - 4; S.GET(tdadr, set) END;
  296.             S.PUT(tdadr, set + mark);
  297.             (*---- mark object*)
  298.             S.PUT(S.VAL(LONGINT, block)-4, marked);
  299.             arraybit := S.VAL(SET, tag) * array;
  300.             IF arraybit # {} THEN
  301.                 cur := block.first;
  302.                 tag := S.VAL(Tag0, S.VAL(SET, tag) - arraybit)
  303.             ELSE cur := block
  304.             END;
  305.             prev := NIL;
  306.             LOOP
  307.                 INC(S.VAL(LONGINT, tag), 4);
  308.                 offset := tag.ptroff;
  309.                 IF offset < 0 THEN  (*up*)
  310.                     INC(S.VAL(LONGINT, tag), offset);
  311.                     IF (arraybit # {}) & (cur # block.last) THEN
  312.                         INC(S.VAL(LONGINT, cur), tag.ptroff)    (* INC(cur, recsize) *)
  313.                     ELSE (* up *)
  314.                         S.PUT(S.VAL(LONGINT, block)-4, S.VAL(SET, tag) + arraybit + mark);
  315.                         IF prev = NIL THEN EXIT END;
  316.                         S.GET(S.VAL(LONGINT, prev)-4, tag);
  317.                         arraybit := S.VAL(SET, tag) * array;
  318.                         tag := S.VAL(Tag0, S.VAL(SET, tag) - array - mark);
  319.                         IF arraybit # {} THEN cur := prev.cur ELSE cur := prev END;
  320.                         adr := S.VAL(LONGINT, cur) + tag.ptroff;
  321.                         S.GET(adr, p);
  322.                         S.PUT(adr, block);
  323.                         block := prev;
  324.                         prev := p
  325.                     END
  326.                 ELSE  (*down*)
  327.                     adr := S.VAL(LONGINT, cur) + offset;
  328.                     S.GET(adr, p);
  329.                     IF S.VAL (LONGINT, p) > 0 THEN
  330.                         S.GET(S.VAL(LONGINT, p)-4, downtag);
  331.                         marked := S.VAL(Tag0, S.VAL(SET, downtag) + mark);
  332.                         IF downtag # marked THEN
  333.                             (*---- mark type descriptor*)
  334.                             tdadr := S.VAL(LONGINT, S.VAL(SET, downtag) - array) - 4;
  335.                             S.GET (tdadr, set); 
  336.                             IF RecBit IN set THEN tdadr := S.VAL(LONGINT, set - {RecBit, MarkBit}) - 4; S.GET(tdadr, set) END;
  337.                             S.PUT(tdadr, set + mark);
  338.                             (*---- mark object*)
  339.                             S.PUT(S.VAL(LONGINT, p)-4, marked);
  340.                             S.PUT(S.VAL(LONGINT, block)-4, S.VAL(SET, tag) + arraybit + mark);
  341.                             IF arraybit # {} THEN block.cur:= cur END;
  342.                             arraybit := S.VAL(SET, downtag) * array;
  343.                             IF arraybit # {} THEN cur := p.first ELSE cur := p END;
  344.                             tag := S.VAL(Tag0, S.VAL(SET, downtag) - arraybit);
  345.                             S.PUT(adr, prev);
  346.                             prev := block;
  347.                             block := p
  348.                         END
  349.                     END
  350.                 END
  351.             END
  352.         END
  353.     END Mark;
  354.     PROCEDURE Sweep;
  355.         VAR p, end: Blockm4; free: FreeBlock; tag, unmarked, tdesc: Tag; size, lastSize, i: LONGINT;
  356.             last: ARRAY N+1 OF FreeBlock;
  357.     BEGIN
  358.         FOR i :=0 TO N DO A[i] := NIL END;
  359.         (*-- sweep through all blocks*)
  360.         p := S.VAL(Blockm4, heapBeg);
  361.         end := S.VAL(Blockm4, heapEnd);
  362.         lastSize := 0;
  363.         WHILE p # end DO
  364.             tag := p.tag;
  365.             unmarked := S.VAL(Tag, S.VAL(SET, tag) - mark);
  366.             tdesc := S.VAL(Tag, S.VAL(SET, unmarked) - array);
  367.             IF unmarked # tdesc THEN (*array block*)
  368.                 size := p.last + tdesc.size - S.VAL(LONGINT, p)
  369.             ELSE size := tdesc.size + 4
  370.             END;
  371.             size := S.VAL(LONGINT, S.VAL(SET, size + B-1) - S.VAL(SET, B-1));
  372.             IF tag = unmarked THEN (*collect*)
  373. Modules.Print ("Size = %d$", size);
  374.                 IF lastSize = 0 THEN free := S.VAL(FreeBlock, p) END;
  375.                 INC(lastSize, size)
  376.             ELSE
  377.                 p.tag := unmarked;
  378.                 IF lastSize > 0 THEN  (*add last free block to free list*)
  379. Modules.Print ("Merged = %d$", lastSize);
  380.                     free.size := lastSize - 4;
  381.                     free.tag := S.VAL(Tag, S.ADR(free.size));
  382.                     i := Min(lastSize DIV B, N);
  383.                     IF A[i] = NIL THEN A[i] := free ELSE last[i].next := free END;
  384.                     last[i] := free; free.next := NIL; lastSize := 0
  385.                 END
  386.             END;
  387.             INC(S.VAL(LONGINT, p), size)
  388.         END;
  389. shrink heap
  390.         (*-- add last free block to free list*)
  391.         IF lastSize > 0 THEN
  392. Modules.Print ("Merged = %d$", lastSize);
  393.             free.size := lastSize - 4;
  394.             free.tag := S.VAL(Tag, S.ADR(free.size));
  395.             i := Min(lastSize DIV B, N);
  396.             IF A[i] = NIL THEN A[i] := free ELSE last[i].next := free END;
  397.             last[i] := free; free.next := NIL
  398.         END
  399.     END Sweep;
  400.     PROCEDURE CheckCandidates (candidates: ARRAY OF LONGINT);    (*nofcand > 0*)
  401.         VAR h, i, j, size, cand, block, last, heapEnd0, prevBlock: LONGINT; tag, unmarked, tdesc: Tag;
  402.     BEGIN
  403.         (*-- sort candidates in increasing order using shellsort *)
  404.         h := 1; REPEAT h := h*3 + 1 UNTIL h > nofcand;
  405.         REPEAT h := h DIV 3; i := h;
  406.             WHILE i < nofcand DO cand := candidates[i]; j := i;
  407.                 WHILE (j >= h) & (candidates[j-h] > cand) DO
  408.                     candidates[j] := candidates[j-h]; j := j-h;
  409.                 END;
  410.                 candidates[j] := cand; INC(i)
  411.             END
  412.         UNTIL h = 1;
  413.         (*-- sweep*)
  414.         block := heapBeg + 4; heapEnd0 := heapEnd + 4;
  415.         i := 0; cand := candidates[i];
  416.         prevBlock := block;
  417.         LOOP
  418.             IF cand <= block THEN
  419.                 IF cand = block THEN
  420.                     S.GET(cand-4, h);
  421.                     IF h # cand THEN Mark(S.VAL(Block, block)) END (* else it is a free block *)
  422.                 ELSE (* cand < block => ptr into a block (e.g. VAR-Par p.x) *)
  423.                     S.GET(prevBlock-4, h);
  424.                     IF h # prevBlock THEN Mark(S.VAL(Block, prevBlock)) END; (* else it is a free block *)
  425.                 END;
  426.                 INC(i);
  427.                 IF i = nofcand THEN EXIT END;
  428.                 cand := candidates[i]
  429.             ELSE (*cand > block*)
  430.                 S.GET(block-4, tag);
  431.                 unmarked := S.VAL(Tag, S.VAL(SET, tag) - mark);
  432.                 tdesc := S.VAL(Tag, S.VAL(SET, unmarked) - array);
  433.                 IF tdesc # unmarked THEN (*array block*) S.GET(block, last); size := last + tdesc.size - block + 4
  434.                 ELSE size := tdesc.size + 4
  435.                 END;
  436.                 prevBlock := block;
  437.                 INC(block, S.VAL(LONGINT, S.VAL(SET, size + B-1) - S.VAL(SET, B-1)));
  438.                 IF block = heapEnd0 THEN EXIT END
  439.             END
  440.         END
  441.     END CheckCandidates;
  442.     PROCEDURE Candidate (VAR cand: ARRAY OF LONGINT; p: LONGINT);
  443.         VAR tag: LONGINT;
  444.     BEGIN
  445.         IF (*(p MOD B = 0) &*) (p >= heapBeg) & (p < heapEnd) THEN
  446. (*                                        ptr into a block possible as well -> less criterias
  447.             S.GET(p-4, tag);
  448.             IF ~ODD(tag) (*unmarked*) THEN
  449.                 candidates[nofcand] := p; INC(nofcand);
  450.                 IF nofcand = LEN(candidates) THEN CheckCandidates; nofcand := 0 END
  451.             END
  452.             cand[nofcand] := p; INC(nofcand);
  453.             IF nofcand = LEN(cand) THEN CheckCandidates (cand); nofcand := 0 END
  454.         END
  455.     END Candidate;
  456.     PROCEDURE SetMark (adr: LONGINT);
  457.         VAR set: SET;
  458.     BEGIN
  459.         S.GET (adr - 4, set); set := set + mark; S.PUT (adr - 4, set)
  460.     END SetMark;
  461.     PROCEDURE CheckMark (adr: LONGINT);
  462.         VAR set: SET;
  463.     BEGIN
  464.         S.GET (adr - 4, set);
  465.         IF MarkBit IN  set THEN Modules.Print ("Check: %x", S.VAL (LONGINT, set)); Modules.Print (", %x$", adr) END;
  466.     END CheckMark;
  467.     PROCEDURE GC*;
  468.         VAR m: Modules.Module; i, data, offset, beg, p: LONGINT; ptr: Block; s: Stack; set: SET; cand: ARRAY 1024 OF LONGINT;
  469.     BEGIN
  470.         IF GCenabled THEN
  471.             prepQ.Handle;
  472.             FOR i := 0 TO N DO A[i] := NIL END;
  473.             m := Modules.modules;
  474.             WHILE m # NIL DO
  475.                 SetMark (S.VAL(LONGINT, m)); SetMark (m.block- 4);
  476.                 data := m.SB;
  477.                 FOR i := 0 TO m.nofptrs - 1 DO
  478.                     S.GET(m.pointers + 4*i, offset);
  479.                     S.GET(data + offset, ptr);
  480.                     IF S.VAL (LONGINT, ptr) > 0 THEN Mark(ptr) END
  481.                 END;
  482.                 FOR i := 0 TO m.noftds - 1 DO
  483.                     S.GET (m.typedescs + 4*i, p);
  484.                     S.GET (p-4, set);
  485.                     p := S.VAL(LONGINT, set - {RecBit, MarkBit});
  486.                     IF RecBit IN set THEN SetMark(p) END
  487.                 END;
  488.                 m := m.link
  489.             END;
  490.             IF checkStack THEN
  491.                 MarkStack;
  492.                 s := firstStack; nofcand := 0;
  493.                 WHILE s # NIL DO
  494.                     i := s.end; beg := s.beg;
  495.                     WHILE i < beg DO
  496.                         S.GET(i, p); 
  497.                         Candidate (cand, p);
  498.                         INC(i, 4)
  499.                     END;
  500.                     s := s.next
  501.                 END;
  502.                 (*-- callee-saved general registers *)
  503.                 S.GETREG(13, p); Candidate(cand, p);
  504.                 S.GETREG(14, p); Candidate(cand, p);
  505.                 S.GETREG(15, p); Candidate(cand, p);
  506.                 S.GETREG(16, p); Candidate(cand, p);
  507.                 S.GETREG(17, p); Candidate(cand, p);
  508.                 S.GETREG(18, p); Candidate(cand, p);
  509.                 S.GETREG(19, p); Candidate(cand, p);
  510.                 S.GETREG(20, p); Candidate(cand, p);
  511.                 S.GETREG(21, p); Candidate(cand, p);
  512.                 S.GETREG(22, p); Candidate(cand, p);
  513.                 S.GETREG(23, p); Candidate(cand, p);
  514.                 S.GETREG(24, p); Candidate(cand, p);
  515.                 S.GETREG(25, p); Candidate(cand, p);
  516.                 S.GETREG(26, p); Candidate(cand, p);
  517.                 S.GETREG(27, p); Candidate(cand, p);
  518.                 S.GETREG(28, p); Candidate(cand, p);
  519.                 S.GETREG(29, p); Candidate(cand, p);
  520.                 S.GETREG(30, p); Candidate(cand, p);
  521.                 IF nofcand > 0 THEN CheckCandidates (cand) END
  522.             END;
  523.             CheckFinObjs;     (* finalization MK *)
  524.             gcQ.Handle;
  525.             Sweep;
  526.             m:= Modules.modules;
  527.             WHILE m # NIL DO
  528. (*                CheckMark (S.VAL(LONGINT, m)); CheckMark (m.block-4);*)
  529.                 FOR i := 0 TO m.noftds - 1 DO
  530.                     S.GET (m.typedescs + 4*i, p);
  531.                     S.GET (p-4, set);
  532.                     p := S.VAL(LONGINT, set - {RecBit, MarkBit});
  533. (*                    IF RecBit IN set THEN CheckMark(p) END*)
  534.                 END;
  535.                 m := m.link
  536.             END;
  537.             FinalizeObjs;  (* finalization MK *)
  538.             afterQ.Handle
  539.         END
  540.     END GC;
  541.     PROCEDURE NewBlock (size: LONGINT): FreeBlock;    (* size MOD B = 0 *)
  542.         VAR i, rest: LONGINT; p, q, lp, lq: FreeBlock;
  543.     BEGIN
  544.         i := Min(size DIV B, N);
  545.         WHILE (i < N) & (A[i] = NIL) DO INC(i) END;
  546.         IF i = N THEN 
  547.             lp := A[i];
  548.             WHILE lp # NIL DO                        (* 17.2.85 mah *)
  549.                 IF lp.size + 4 >= size THEN
  550.                     IF (p = NIL) OR (p.size > lp.size) THEN p :=  lp; q := lq END
  551.                 END;
  552.                 lq := lp; lp := lp.next
  553.             END;
  554.             IF p = NIL THEN
  555.                 IF firstTry THEN
  556.                     GC;
  557.                     firstTry := FALSE; p := NewBlock(size); firstTry := TRUE;
  558.                     RETURN p
  559.                 ELSE
  560.                     Modules.Print("--- heap overflow$", 0); HALT(20)
  561.                 END
  562.             ELSIF q # NIL THEN q.next := p.next
  563.             ELSE A[N] := p.next
  564.             END
  565.         ELSE (*p # NIL *) p := A[i]; A[i] := p.next
  566.         END;
  567.         rest := p.size + 4 - size;
  568.         IF rest > 0 THEN
  569.             IF size > 10 * 1024 THEN
  570.                 q := p;
  571.                 p := S.VAL(FreeBlock, S.VAL(LONGINT, p) + rest)
  572.             ELSE
  573.                 q := S.VAL(FreeBlock, S.VAL(LONGINT, p) + size)
  574.             END;
  575.             q.tag := S.VAL(Tag, S.ADR(q.size));
  576.             q.size := rest - 4;
  577.             i := Min(rest DIV B, N); q.next := A[i]; A[i] := q
  578.         END;
  579.         RETURN p
  580.     END NewBlock;
  581.     PROCEDURE NewRec (tg: LONGINT): LONGINT;    (* implementation of NEW(p) *)
  582.         VAR size, null: LONGINT; p, q: FreeBlock; tag: Tag;    BEGIN (* tag.size = rectyp.size *)
  583.         tag := S.VAL(Tag, tg);
  584.         size := S.VAL(LONGINT, S.VAL(SET, tag.size + 4 (*tag*) + B-1) - S.VAL(SET, B-1));
  585.         p := NewBlock(size);
  586.         (*-- the following code is optimized for RISC processors*)
  587.         q := S.VAL(FreeBlock, S.VAL(LONGINT, p) + size - B);
  588.         null := 0;
  589.         q.size := null; q.next := S.VAL(FreeBlock, null); q.filler := null;
  590.         WHILE q # p DO
  591.             DEC(S.VAL(LONGINT, q), B);
  592.             q.size := null; q.next := S.VAL(FreeBlock, null); q.filler := null; q.firstofnext := null (* q.firstofnext is in next block *)
  593.         END;
  594.         p.tag := tag;
  595.         RETURN S.VAL(LONGINT, p) + 4
  596.     END NewRec;
  597.     PROCEDURE NewSys (size: LONGINT): LONGINT;    (* implementation of S.NEW(p, size) *)
  598.         VAR p, q: FreeBlock; null: LONGINT;
  599.     BEGIN                                                        (* mah:   v  12 statt 8 to allow NEW (string, 4) to work correctly *)
  600.         size := S.VAL(LONGINT, S.VAL(SET, size + (4 (*tag*) + 12 (*dummyTD*) + B-1)) - S.VAL(SET, B-1));
  601.         p := NewBlock(size);
  602.         (*-- set up dummyTD at the end of the block in order to treat system blocks like unmarked blocks*)
  603.         q := S.VAL(FreeBlock, S.VAL(LONGINT, p) + size - B);
  604.         p.tag := S.VAL(Tag, S.ADR(q.next));
  605.         q.size := 0; q.next := S.VAL(FreeBlock, size - 4); q.filler := -4;
  606.         (*-- the following code is optimized for RISC processors*)
  607.         null := 0;
  608.         WHILE q # p DO
  609.             DEC(S.VAL(LONGINT, q), B);
  610.             q.size := null; q.next := S.VAL(FreeBlock, null); q.filler := null; q.firstofnext := null (* q.firstofnext is in next block *)
  611.         END;
  612.         RETURN S.VAL(LONGINT, p) + 4
  613.     END NewSys;
  614.     PROCEDURE NewArr (eltg, nofelem, nofdim: LONGINT): LONGINT; (* implementation of NEW(p, dim0, dim1, ...) *)
  615.         VAR size, first, elSize, arrSize, vectSize, null: LONGINT; p, q: Blockm4; eltag: Tag;
  616.     BEGIN
  617.         eltag := S.VAL(Tag, eltg);
  618.         IF eltag = NIL THEN (*ARRAY OF POINTER*) eltag := S.VAL(Tag, S.ADR(PointerTD[1])) END;
  619.         elSize := eltag.size;
  620.         arrSize := nofelem*elSize;
  621.         vectSize := 8*(nofdim DIV 2) + 4;    (* -> ADR(first) MOD 8 = 0 *)
  622.         IF eltag.ptroff = -4 THEN (*no pointers in element type*) RETURN NewSys(arrSize + vectSize + 12) END;
  623.         size := S.VAL(LONGINT, S.VAL(SET, arrSize + vectSize + (16 + B-1))-S.VAL(SET, B-1));
  624.         p := S.VAL(Blockm4, NewBlock(size));
  625.         q := S.VAL(Blockm4, S.VAL(LONGINT, p) + size - 2*B);
  626.         (*-- the following code is optimized for RISC processors*)
  627.         null := 0;
  628.         q.filler1 := null; q.filler2 := null; q.filler3 := null;
  629.         WHILE q # p DO
  630.             DEC(S.VAL(LONGINT, q), B);
  631.             q.filler1 := null; q.filler2 := null; q.filler3 := null; q.firstofnext := null (* q.firstofnext is in next block *)
  632.         END;
  633.         p.tag := S.VAL(Tag, S.VAL(SET, eltag) + array);
  634.         first := S.ADR(p.first) + 4 + vectSize;
  635.         p.last := first + arrSize - elSize;
  636.         (*p.cur is reserved for Mark phase*)
  637.         p.first := first;
  638.         p.filler0 := null;
  639.         RETURN S.VAL(LONGINT, p) + 4
  640.     END NewArr;
  641. (* --- trap handling --- *)
  642.     PROCEDURE MarkState*;    (*called at the very beginning of Oberon.Loop*)
  643.         VAR SP: LONGINT;
  644.     BEGIN
  645.         S.GETREG(1, SP); S.GET(SP, resumeSP); S.GET (resumeSP-4, resumeFP); S.GETREG(40 (*LR*), resumePC);
  646.         curStack := S.VAL(Stack, NewRec(S.ADR(stackTD)+4)); curStack.beg := resumeSP; curStack.next := NIL;
  647.         firstStack := curStack
  648.     END MarkState;
  649.     PROCEDURE Resume* (context: Sys.ExceptionInfo);
  650.     BEGIN
  651.         context.reg.R[31*2+1] := resumeFP;
  652.         context.spec.PC := resumePC;
  653.     END Resume;
  654. (* --- initialization --- *)
  655.     PROCEDURE Init;
  656.         VAR a: LONGINT; size, i: LONGINT; p: FreeBlock;
  657.     BEGIN
  658.         firstTry := TRUE; GCenabled := TRUE; checkStack := TRUE;
  659.         Modules.NewRec := NewRec; Modules.NewSys := NewSys; Modules.NewArr := NewArr;
  660.         PointerTD[0] := S.VAL(LONGINT, mark);    (*marked*)
  661.         PointerTD[1] := 4;    (*pointer size*)
  662.         PointerTD[2] := 0;    (*pointer offset in element*)
  663.         PointerTD[3] := -8;    (*sentinel*)
  664.         stackTD[0] := S.VAL(LONGINT, mark);
  665.         stackTD[1] := 12;  (*size*)
  666.         stackTD[2] := 8;   (*offset of next*)
  667.         stackTD[3] := -8; (*sentinel*)
  668.         quitQ.Init; gcQ.Init; prepQ.Init; afterQ.Init;
  669.         finObjs := NIL; finalize := FALSE; (* finalization MK *)
  670.         (*-- allocate heap; adjust to multiple of B minus 4*)
  671.         AllocateHeap;
  672.         heapBeg := heapAdr + ((-heapAdr-4) MOD B);    (*B aligned - 4*)
  673.         size := heapAdr + heapSize - heapBeg;
  674.         DEC(size, size MOD B);
  675.         heapEnd := heapBeg + size;    (*B aligned - 4*)
  676.         (*-- make the whole heap a single free block*)
  677.         p := S.VAL(FreeBlock, heapBeg);
  678.         p.tag := S.VAL(Tag, S.ADR(p.size)); p.size := size - 4; p.next := NIL;
  679.         A[N] := p;
  680.         FOR i := 0 TO N-1 DO A[i] := NIL END;
  681.     END Init;
  682. BEGIN
  683.     Init
  684. END Kernel.
  685.     PROCEDURE ExpandHeap (requiredSize: LONGINT);    
  686.     PROCEDURE ShrinkHeap (lastSize: LONGINT): LONGINT;    
  687.     PROCEDURE PrintType (p: LONGINT);    
  688.